home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic Source Code
/
Visual Basic Source Code.iso
/
vbsource
/
geodem
/
csc5.bas
< prev
next >
Wrap
BASIC Source File
|
1995-05-09
|
25KB
|
696 lines
'3D CyberSpace viewer from...
'Ivory Tower Software
'Richard Wagner
'CIS 76427,2611
'Copyright 1992, all rights reserved.
'You may use this VB source code in your programs if you include attribution in your
'startup and "about" screens in the form: "Portions of this program copyright by
'Ivory Tower Software, used with permission."
Sub BorderBoxRaised (Source1 As Control, Source2 As Form)
Source2.drawwidth = 1
Bleft% = Source1.Left - 15
BTop% = Source1.top - 15
BWide% = Source1.width + 15
BHigh% = Source1.height + 15
Source2.Line (Bleft%, BTop%)-Step(BWide%, 0), &HFFFFFF
Source2.Line -Step(0, BHigh%), 0
Source2.Line -Step(-BWide%, 0), 0
Source2.Line -Step(0, -BHigh%), &HFFFFFF
End Sub
Sub BorderBoxRecessed (Source1 As Control, Source2 As Form)
Source2.drawwidth = 1
Bleft% = Source1.Left - 20
BTop% = Source1.top - 20
BWide% = Source1.width + 15
BHigh% = Source1.height + 15
Source2.Line (Bleft%, BTop%)-Step(BWide%, 0), 0
Source2.Line -Step(0, BHigh%), &HFFFFFF
Source2.Line -Step(-BWide%, 0), &HFFFFFF
Source2.Line -Step(0, -BHigh%), 0
End Sub
Sub MapToWindow (ByVal PointNum As Integer, ByVal X, ByVal Y, ByVal Z)
'Transform object point in World Space to View Space.
'Call GEO.DLL subroutine:
ThreeDXForm 1000, 1000, X, Y, Z, sfViewPointX, sfViewPointY, sfViewPointZ, sfWinPointX, sfWinPointY, sfWinPointZ, sfRPointX, sfRPointY, sfRPointZ, sfSPointX, sfSPointY, sfSPointZ, PxStar, PyStar, PzStar
'Transform object point in View 3Space to Window 2Space:
If PzStar <> 0 Then
PxStar = -PxStar * 1000 / PzStar
PyStar = -PyStar * 1000 / PzStar
Else
PxStar = -PxStar * 1000 * 30000 'Can't divide by zero so
PyStar = -PyStar * 1000 * 30000 'do the next best thing
End If
'Convert mapped points to integers for drawing:
If PxStar <= 30000 And PxStar >= -30000 Then
iPx(PointNum) = CInt(PxStar)
Else
iPx(PointNum) = 30000 * Sgn(PxStar)
End If
If PyStar <= 30000 And PyStar >= -30000 Then
iPy(PointNum) = CInt(PyStar)
Else
iPy(PointNum) = 30000 * Sgn(PyStar)
End If
If PzStar <= 30000 And PzStar >= -30000 Then
iPz(PointNum) = CInt(PzStar)
Else
iPz(PointNum) = 30000 * Sgn(PzStar)
End If
End Sub
Sub PicBorderBoxRecessed (Source1 As Control, Source2 As Control)
Source2.drawwidth = 1
Bleft% = Source1.Left - 15
BTop% = Source1.top - 15
BWide% = Source1.width + 15
BHigh% = Source1.height + 15
Source2.Line (Bleft%, BTop%)-Step(BWide%, 0), 0
Source2.Line -Step(0, BHigh%), &HFFFFFF
Source2.Line -Step(-BWide%, 0), &HFFFFFF
Source2.Line -Step(0, -BHigh%), 0
End Sub
Sub PlaceAllObjects ()
'All the defined objects get placed in cyberspace, with more distant objects
'getting placed first.
XView.mousepointer = 11
For i% = 1 To iNumObjects
'Find distances squared of objects' centers from ViewPoint:
'There is no need to take the square root, because it's the distance order we want.
sfDSquared(i%) = (iLocationX(i%) - sfViewPointX) ^ 2 + (iLocationY(i%) - sfViewPointY) ^ 2 + (iLocationZ(i%) - sfViewPointZ) ^ 2
'Initialize object order array:
iObjOrder(i%) = i%
Next i%
'Sort objects by their distances squared:
'Bubble sort
For i% = 1 To iNumObjects - 1
For j% = i% + 1 To iNumObjects
If sfDSquared(i%) < sfDSquared(j%) Then
Temp1! = sfDSquared(i%)
sfDSquared(i%) = sfDSquared(j%)
sfDSquared(j%) = Temp1!
Temp2! = iObjOrder(i%)
iObjOrder(i%) = iObjOrder(j%)
iObjOrder(j%) = Temp2!
End If
Next j%
Next i%
For i% = 1 To iNumObjects
'See if center of object is outside view pyramid by 500 CLUs:
'Objects completely out of view don't get drawn.
'This means that the biggest object in cyberspace cannot be bigger than
'1000 CLUs in any dimension.
NewX! = iLocationX(i%) - sfViewPointX
NewY! = iLocationY(i%) - sfViewPointY
NewZ! = iLocationZ(i%) - sfViewPointZ
CenterXstar& = (sfRPointX - sfWinPointX) * NewX! / 500 + (sfRPointY - sfWinPointY) * NewY! / 500 + (sfRPointZ - sfWinPointZ) * NewZ! / 500
CenterYstar& = (sfSPointX - sfWinPointX) * NewX! / 500 + (sfSPointY - sfWinPointY) * NewY! / 500 + (sfSPointZ - sfWinPointZ) * NewZ! / 500
CenterZstar& = (sfViewPointX - sfWinPointX) * NewX! / 1000 + (sfViewPointY - sfWinPointY) * NewY! / 1000 + (sfViewPointZ - sfWinPointZ) * NewZ! / 1000
iInView(i%) = -1
If CenterXstar& > (1000 - CenterZstar&) / 2 Then
iInView(i%) = 0
End If
If CenterXstar& < (CenterZstar& - 1000) / 2 Then
iInView(i%) = 0
End If
If CenterYstar& > (1000 - CenterZstar&) / 2 Then
iInView(i%) = 0
End If
If CenterYstar& < (CenterZstar& - 1000) / 2 Then
iInView(i%) = 0
End If
Next i%
For i% = 1 To iNumObjects
'Erase
'Objects are explicitly erased for smooth drawing.
If iInViewPrev(iObjOrder(i%)) Then PlaceObject iObjOrder(i%), -1
Next i%
For i% = 1 To iNumObjects
'Place
If iInView(iObjOrder(i%)) Then PlaceObject iObjOrder(i%), 0
iInViewPrev(i%) = iInView(i%)
Next i%
XView.mousepointer = 0
End Sub
Sub PlaceObject (ObjNum As Integer, iErase As Integer)
'Each object is placed separately after erasing its old placement.
'Cls is not used because that makes a flickering view port.
On Error GoTo PlaceObjectHandler
If Not iErase Then 'Placing objects, so calculate transformations:
For i% = 1 To iNumPoints(iObjectType(ObjNum)) 'Do it for each point in the object:
'Point is referenced to iLocationX, Y, Z of object center relative to the viewpoint:
NewX! = iObjectX(iObjectType(ObjNum), i%) * sfSize(ObjNum) + iLocationX(ObjNum) - sfViewPointX
NewY! = iObjectY(iObjectType(ObjNum), i%) * sfSize(ObjNum) + iLocationY(ObjNum) - sfViewPointY
NewZ! = iObjectZ(iObjectType(ObjNum), i%) * sfSize(ObjNum) + iLocationZ(ObjNum) - sfViewPointZ
MapToWindow i%, NewX!, NewY!, NewZ!
Next i%
End If
'Each object is drawn depending on its type:
Select Case iObjectType(ObjNum)
Case 1, 44 'Wireframe Cube
If iErase Then 'Erase previous rendering of the object:
'(doing CLS makes a jumpy flickering picture)
If PzOld(ObjNum, 1) < 0 Or PzOld(ObjNum, 2) < 0 Then
If (Abs(PxOld(ObjNum, 1)) < 500 And Abs(PyOld(ObjNum, 1)) < 500) Or (Abs(PxOld(ObjNum, 2)) < 500 And Abs(PyOld(ObjNum, 2)) < 500) Then
XView.ViewPic.Line (PxOld(ObjNum, 1), PyOld(ObjNum, 1))-(PxOld(ObjNum, 2), PyOld(ObjNum, 2)), QBColor(7)
End If
End If
If PzOld(ObjNum, 2) < 0 Or PzOld(ObjNum, 3) < 0 Then
If (Abs(PxOld(ObjNum, 2)) < 500 And Abs(PyOld(ObjNum, 2)) < 500) Or (Abs(PxOld(ObjNum, 3)) < 500 And Abs(PyOld(ObjNum, 3)) < 500) Then
XView.ViewPic.Line (PxOld(ObjNum, 2), PyOld(ObjNum, 2))-(PxOld(ObjNum, 3), PyOld(ObjNum, 3)), QBColor(7)
End If
End If
If PzOld(ObjNum, 3) < 0 Or PzOld(ObjNum, 4) < 0 Then
If (Abs(PxOld(ObjNum, 3)) < 500 And Abs(PyOld(ObjNum, 3)) < 500) Or (Abs(PxOld(ObjNum, 4)) < 500 And Abs(PyOld(ObjNum, 4)) < 500) Then
XView.ViewPic.Line (PxOld(ObjNum, 3), PyOld(ObjNum, 3))-(PxOld(ObjNum, 4), PyOld(ObjNum, 4)), QBColor(7)
End If
End If
If PzOld(ObjNum, 4) < 0 Or PzOld(ObjNum, 1) < 0 Then
If (Abs(PxOld(ObjNum, 4)) < 500 And Abs(PyOld(ObjNum, 4)) < 500) Or (Abs(PxOld(ObjNum, 1)) < 500 And Abs(PyOld(ObjNum, 1)) < 500) Then
XView.ViewPic.Line (PxOld(ObjNum, 4), PyOld(ObjNum, 4))-(PxOld(ObjNum, 1), PyOld(ObjNum, 1)), QBColor(7)
End If
End If
If PzOld(ObjNum, 5) < 0 Or PzOld(ObjNum, 6) < 0 Then
If (Abs(PxOld(ObjNum, 5)) < 500 And Abs(PyOld(ObjNum, 5)) < 500) Or (Abs(PxOld(ObjNum, 6)) < 500 And Abs(PyOld(ObjNum, 6)) < 500) Then
XView.ViewPic.Line (PxOld(ObjNum, 5), PyOld(ObjNum, 5))-(PxOl